(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open UniTools
open UTypes

type hyph_table = {
  ht_char_classes  : int CharMap.charmap;
  ht_pattern_trie  : (int array) Trie.trie;
  ht_pattern_start : int;
}

let create_table ~char_classes:classes ~pattern_trie:trie ~pattern_start:start =
  { ht_char_classes = classes;
    ht_pattern_trie = trie;
    ht_pattern_start = start }

(* parsing *)
let skip_comment stream = while ( != ) (UCStream.pop stream) 10 do () done
  
let rec skip_blanks stream =
  let c = UCStream.next_char stream in
    if (0 <= c) && (c <= 32) then
      let _ = UCStream.pop stream in
        skip_blanks stream
    else if
      c = 37 then                       (* % *) 
        skip_comment stream
    else
      ()
  
let read_next_word stream =
  skip_blanks stream;
  let rec iter () =
    let c = UCStream.pop stream in
      if (c <= 32) || (c = 37) then
        []
      else
        c :: (iter ())
  in
    iter ()
  
let parse_file stream =
  let section_header word =
    match UString.to_string word with
      | "substitute:" -> `Classes
      | "patterns:" -> `Patterns
      | "exceptions:" -> `Exceptions
      | "language:" -> `Language
      | _ -> `None in

  let classes = ListBuilder.make () in
  let patterns = ListBuilder.make () in
  let exceptions = ListBuilder.make () in

  let rec read_classes language =
    let w = read_next_word stream in
      if w = [] then
        (language, (ListBuilder.get classes), (ListBuilder.get patterns),
         (ListBuilder.get exceptions))
      else
        (match section_header w with
           | `Classes -> read_classes language
           | `Patterns -> read_patterns language
           | `Exceptions -> read_exceptions language
           | `Language -> read_language language
           | `None -> (ListBuilder.add classes w; read_classes language))

  and read_patterns language =
    let w = read_next_word stream
    in
      if w = []
      then
        (language, (ListBuilder.get classes), (ListBuilder.get patterns),
         (ListBuilder.get exceptions))
      else
        (match section_header w with
           | `Classes -> read_classes language
           | `Patterns -> read_patterns language
           | `Exceptions -> read_exceptions language
           | `Language -> read_language language
           | `None -> (ListBuilder.add patterns w; read_patterns language))

  and read_exceptions language =
    let w = read_next_word stream
    in
      if w = []
      then
        (language, (ListBuilder.get classes), (ListBuilder.get patterns),
         (ListBuilder.get exceptions))
      else
        (match section_header w with
           | `Classes -> read_classes language
           | `Patterns -> read_patterns language
           | `Exceptions -> read_exceptions language
           | `Language -> read_language language
           | `None -> (ListBuilder.add exceptions w; read_exceptions language))

  and read_language language =
    let w = read_next_word stream
    in
      if w = []
      then
        (language, (ListBuilder.get classes), (ListBuilder.get patterns),
         (ListBuilder.get exceptions))
      else
        (match section_header w with
           | `Classes -> read_classes language
           | `Patterns -> read_patterns language
           | `Exceptions -> read_exceptions language
           | `Language -> read_language language
           | `None -> read_language w) in

  let rec find_section () =
    match section_header (read_next_word stream) with
      | `Classes -> read_classes []
      | `Patterns -> read_patterns []
      | `Exceptions -> read_exceptions []
      | `Language -> read_language []
      | `None -> find_section ()
  in find_section ()
  
let empty_map = CharMap.create 0
  
let make_charmap classes =
  let map = CharMap.copy empty_map in
  let rec iter n classes =
    match classes with
      | [] -> map
      | c :: cs ->
          (List.iter (fun x -> CharMap.set map x n) c; iter (n + 1) cs)
  in iter 1 classes
  
let parse_pattern class_table pattern =
  let rec iter pattern ps ns =
    match pattern with
      | [] -> ((List.rev ps), (List.rev ns))
      | c :: cs ->
          if (c >= 48) && (c <= 57)
          then iter cs ps ((c - 48) :: (List.tl ns))
          else (* number *)
            iter cs ((CharMap.lookup class_table c) :: ps) (0 :: ns)
  in iter pattern [] [ 0 ]
  
(* character *)
let force_break = 11
let force_none = 10
  
let parse_exception class_table except =
  (*
    We append code 0 characters at both sides of the word, insert a break of
    value 11 at every position with a hyphen and the value 10 at all other
    positions. These values are greater then all numbers in the patterns.
  *)
  let rec iter except es hs =
    match except with
      | [] -> ((List.rev (0 :: es)), (List.rev (force_none :: hs)))
      | c :: cs ->
          if c = 45
          then iter cs es (force_break :: (List.tl hs))
          else
            iter cs ((CharMap.lookup class_table c) :: es) (force_none :: hs)
  in iter except [ 0 ] [ force_none; force_none ]
  
let build_trie max_code entries =
  let rec merge i entries =
    match entries with
      | [] -> []
      | (_, _, _, p, e) :: es ->
          (List.rev_map
             (fun (str, ns) -> ((Array.of_list (i :: str)), (Array.of_list ns)))
             p)
          @
            ((List.rev_map
                (fun (str, ns) ->
                   ((Array.of_list (i :: str)), (Array.of_list ns)))
                e)
             @ (merge (i + 1) es))
  in Trie.build max_code (merge 0 entries)
  
let build_table data =
  let parse_entry (l, c, p, e) =
    let cmap = make_charmap c
    in
      ((List.length c), (Array.of_list l), cmap,
       (List.rev_map (parse_pattern cmap) p),
       (List.rev_map (parse_exception cmap) e)) in
  let entries = List.rev_map parse_entry data in
  let max_code =
    List.fold_left (fun x (y, _, _, _, _) -> max x y) 0 entries in
  let trie = build_trie max_code entries in
  let rec iter i entries =
    match entries with
      | [] -> []
      | (_, l, c, _, _) :: xs ->
          let hyphenator =
            create_table
              ~char_classes:c
              ~pattern_trie:trie
              ~pattern_start:(Trie.get_offset trie i)
          in
            (l, hyphenator) :: (iter (i + 1) xs)
  in
    (trie, (iter 0 entries))
  
(* output routines *)
let print_list p l =
  (print_string "[";
   let rec iter l =
     match l with
       | [] -> print_string "]"
       | [ x ] -> (p x; print_string "]")
       | x :: xs -> (p x; print_string "; "; iter xs)
   in iter l)
  
let print_array p newline a =
  let len = Array.length a in
    print_string "[|";
    if len > 1 then
      for i = 0 to len - 2 do
        p a.(i);
        if newline then
          print_string ";\n"
        else
          print_string "; "
      done
    else
      ();
    if len > 0 then
      p a.(len - 1)
    else
      ();
    print_string "|]"
  
let dump_trie trie p =
  print_string "{ t_tree = ";
  print_array print_int false trie.Trie.t_tree;
  print_string "; t_data = ";
  print_array (print_array p false) true trie.Trie.t_data;
  print_string "; t_data_len = ";
  print_int trie.Trie.t_data_len;
  print_string "};\n"
  
let dump_charmap cmap =
  let is_empty cmap n =
    let rec iter i =
      if i = (256 * (n + 1))
      then true
      else if (CharMap.lookup cmap i) <> 0 then false else iter (i + 1)
    in iter (256 * n)
  in
    print_string "CharMap.build [|";
    for n = 0 to 255 do
      if is_empty cmap n
      then print_string "empty_map"
      else
        (let a =
           Array.init 256 (fun i -> CharMap.lookup cmap ((256 * n) + i))
         in print_array print_int false a);
      if n < 255 then
        print_string ";\n"
      else
        print_string "\n"
    done;
    print_string "|]"
  
let dump_table (lang, ht) =
  print_string "begin";
  print_array print_int false lang;
  print_string ",\n";
  print_string "create_table\n";
  print_string "~char_classes:\nbegin\n";
  dump_charmap ht.ht_char_classes;
  print_string "end\n";
  print_string "~pattern_trie:main_trie\n";
  print_string "~pattern_start:";
  print_int ht.ht_pattern_start;
  print_string "\nend\n"
  
let output_table (trie, tables) =
  print_endline "open Trie;;";
  print_endline "open Hyphenation;;";
  print_endline "let main_trie =";
  dump_trie trie print_int;
  print_endline ";;";
  print_endline "let empty_map =";
  print_array print_int false (Array.make 256 0);
  print_endline ";;";
  print_endline "let tables =";
  print_list dump_table tables;
  print_endline ";;"
  
let main () =
  UString.set_string_format `UTF8;
  let rec iter i =
    if i >= (Array.length Sys.argv) then
      []
    else
      try
        let _ = Unix.stat Sys.argv.(i) in
        let stream = UCStream.of_file (UniText.of_string Sys.argv.(i)) in
        let x = parse_file stream in
          x :: (iter (i + 1))
      with
        | Unix.Unix_error (err, _, _) ->
            Printf.eprintf "%s: %s\n" Sys.argv.(i) (Unix.error_message err);
            iter (i + 1)
        | _ ->
            Printf.eprintf "Cannot read file %s!\n" Sys.argv.(i);
            iter (i + 1)
  in
    output_table (build_table (iter 1))
  
let _ = main ()
